home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Shareware Overload Trio 2
/
Shareware Overload Trio Volume 2 (Chestnut CD-ROM).ISO
/
dir44
/
dungn32.zip
/
PARSER.FOR
< prev
next >
Wrap
Text File
|
1994-10-08
|
64KB
|
1,734 lines
C Parser for DUNGEON
C
C COPYRIGHT 1980, 1990, INFOCOM COMPUTERS AND COMMUNICATIONS, CAMBRIDGE MA.
C ALL RIGHTS RESERVED, COMMERCIAL USAGE STRICTLY PROHIBITED
C WRITTEN BY R. M. SUPNIK
C
C 29-Sep-94 RMS Fixed bugs in PLAY WITH, ALL BUT, GWIM, THISIT, IT.
C Fixed vocabularly for ROCK, LIGHT, GATES, STACK,
C BLIND. Added COUNT, PERUSE, BLESSING, GHOSTS,
C SPIRITS, CLIFFS, CORPSES, OUTPUT, CHIMNEY,
C ZORKMID adjective, DIGBT flag.
C 30-Jan-94 RMS Fixed bug in error message.
C 30-Jun-92 RMS Changed file names to lower case.
C 29-Jun-92 RMS Removed extraneous declaration from SPARSE.
C Added dummy argument to SYNMCH.
C
C RDLINE- Read input line
C
C Declarations
C
SUBROUTINE RDLINE(INLINE,INLEN,WHO)
IMPLICIT INTEGER(A-Z)
INCLUDE 'dparam.for'
CHARACTER*(TEXLNT) INLINE
C
LUCVT=ICHAR('A')-ICHAR('a') ! case conversion factor.
5 GO TO (90,10),WHO+1 ! see who to prompt for.
10 WRITE(OUTCH,50) ! prompt for game.
50 FORMAT(' >',$)
C
90 READ(INPCH,100,END=5) INLINE ! get input.
100 FORMAT(A)
C
INLEN=NBLEN(INLINE) ! len w/o trailing blanks.
IF(INLEN.LE.0) GO TO 5 ! anything left?
DO 400 I=1,INLEN ! convert to upper case.
IF((INLINE(I:I).GE.'a').AND.(INLINE(I:I).LE.'z'))
1INLINE(I:I)=CHAR(ICHAR(INLINE(I:I))+LUCVT)
400 CONTINUE
PRSCON=1 ! restart lex scan.
RETURN
END
C PARSE- Top level parse routine
C
C Declarations
C
C This routine details on bit 0 of PRSFLG
C
LOGICAL FUNCTION PARSE(INLINE,INLEN,VBFLAG)
IMPLICIT INTEGER(A-Z)
INCLUDE 'dparam.for'
CHARACTER*(TEXLNT) INLINE
CHARACTER*(WRDLNT) OUTBUF(LEXMAX),BAKBUF(LEXMAX)
LOGICAL LEX,SYNMCH,DFLAG,VBFLAG
SAVE BAKBUF,BAKLEN
DATA BAKBUF(1)/'L'/,BAKLEN/1/
C
DFLAG=(PRSFLG.AND.1).NE.0
PARSE=.FALSE. ! assume fails.
PRSA=0 ! zero outputs.
PRSI=0
PRSO=0
C
IF(.NOT.LEX(INLINE,INLEN,OUTBUF,OUTLEN,VBFLAG)) GO TO 1000
IF((OUTLEN.NE.1).OR.(OUTBUF(1).NE.'AGAIN')) GO TO 100
DO 50 I=1,LEXMAX ! use previous
OUTBUF(I)=BAKBUF(I)
50 CONTINUE
OUTLEN=BAKLEN ! buffer and length.
100 IF(SPARSE(OUTBUF,OUTLEN,VBFLAG)) 1000,200,300 ! do syn scan.
C
C Parse requires validation
C
200 IF(.NOT.VBFLAG) GO TO 350 ! echo mode, force fail.
IF(.NOT.SYNMCH(X)) GO TO 1000 ! do syn match.
IF(PRSO.EQ.BUNOBJ) LASTIT=BUNVEC(1) ! record for "it".
IF((PRSO.GT.0).AND.(PRSO.LT.BUNOBJ)) LASTIT=PRSO
C
C Successful parse or successful validation
C
300 PARSE=.TRUE.
350 CALL ORPHAN(0,0,0,0,0,' ',0,0) ! clear orphans.
DO 400 I=1,LEXMAX ! save command
BAKBUF(I)=OUTBUF(I)
400 CONTINUE
BAKLEN=OUTLEN ! save length
IF(DFLAG) WRITE(OUTCH,500) PARSE,PRSA,PRSO,PRSI
500 FORMAT(' PARSE RESULTS- ',L7,3I7)
RETURN
C
C Parse fails, disallow continuation
C
1000 PRSCON=1
IF(DFLAG) WRITE(OUTCH,500) PARSE,PRSA,PRSO,PRSI
RETURN
C
END
C LEX- Lexical analyzer
C
C Declarations
C
C This routine details on bit 1 of PRSFLG
C
LOGICAL FUNCTION LEX(INLINE,INLEN,OUTBUF,OP,VBFLAG)
IMPLICIT INTEGER(A-Z)
INCLUDE 'dparam.for'
CHARACTER*(TEXLNT) INLINE
CHARACTER*(WRDLNT) OUTBUF(LEXMAX)
CHARACTER*1 J
LOGICAL DFLAG,VBFLAG
C
DFLAG=(PRSFLG.AND.2).NE.0
LEX=.FALSE. ! assume lex fails.
OP=0 ! output ptr.
DO 10 I=1,LEXMAX ! clear output buf.
OUTBUF(I)=' '
10 CONTINUE
C
50 OP=OP+1 ! adv output ptr.
CP=0 ! char ptr=0.
C
200 IF(PRSCON.GT.INLEN) GO TO 2000 ! end of input?
J=INLINE(PRSCON:PRSCON) ! no, get character,
IF((J.EQ.'"').OR.(J.EQ.'''')) GO TO 3000! substring?
PRSCON=PRSCON+1 ! advance ptr.
IF(J.EQ.' ') GO TO 1000 ! space?
IF((J.EQ.'.').OR.(J.EQ.';').OR.
1 (J.EQ.'!').or.(J.EQ.'?')) GO TO 2000 ! end of command?
IF(J.EQ.',') GO TO 4000 ! comma?
IF(OP.GT.LEXMAX) GO TO 5000 ! too many tokens?
CP=CP+1 ! adv char ptr.
IF(CP.LE.WRDLNT) OUTBUF(OP)(CP:CP)=J ! insert char in word.
GO TO 200
C
C Space.
C
1000 IF(CP.EQ.0) GO TO 200 ! any word yet?
GO TO 50 ! yes, adv op.
C
C End of input, see if partial word available.
C
2000 IF(PRSCON.GT.INLEN) PRSCON=1 ! force parse restart.
IF((CP.EQ.0).AND.(OP.EQ.1)) RETURN ! any results?
IF(CP.EQ.0) OP=OP-1 ! any last word?
LEX=.TRUE.
IF(DFLAG) WRITE(OUTCH,2020) CP,OP,PRSCON,(OUTBUF(I),I=1,OP)
2020 FORMAT(' LEX RESULTS- ',3I7/1X,8(A,1X))
RETURN
C
C Substring, J is delimiter.
C
3000 IF(SUBLNT.NE.0) GO TO 3400 ! already got one?
3100 PRSCON=PRSCON+1 ! skip initial quote.
IF(PRSCON.GT.INLEN) GO TO 3500 ! any more characters?
IF(INLINE(PRSCON:PRSCON).EQ.' ') GO TO 3100 ! skip blanks.
K=INDEX(INLINE(PRSCON:INLEN),J) ! find closing quote.
IF(K.LE.1) GO TO 3500 ! none or empty?
SUBBUF=INLINE(PRSCON:PRSCON+K-2) ! set up substring buffer,
SUBLNT=K-1 ! length.
PRSCON=PRSCON+K ! skip over string.
IF(DFLAG) WRITE(OUTCH,3030) SUBLNT,SUBBUF(1:SUBLNT)
3030 FORMAT(' SUBSTRING- ',I7,' "',A,'"')
GO TO 1000 ! treat as end of word.
C
3400 IF(VBFLAG) CALL RSPEAK(1046) ! multiple substrings.
RETURN
C
3500 IF(VBFLAG) CALL RSPEAK(616) ! bad substring.
RETURN ! fails.
C
C Comma.
C
4000 IF(CP.NE.0) OP=OP+1 ! if partial word, go to next.
IF(OP.EQ.1) GO TO 4500 ! no first word? die.
IF(OP.GT.LEXMAX) GO TO 5000 ! too many tokens?
OUTBUF(OP)='AND' ! insert 'AND'.
GO TO 50 ! start new word
C
4500 IF(VBFLAG) CALL RSPEAK(1047) ! misplaced comma.
RETURN
C
C Too many tokens.
C
5000 IF(VBFLAG) CALL RSPEAK(1048) ! too many tokens.
RETURN
C
END
C SPARSE- Start of parse
C
C Declarations
C
C This routine details on bit 2 of PRSFLG
C
INTEGER FUNCTION SPARSE(LBUF,LLNT,VBFLAG)
IMPLICIT INTEGER(A-Z)
INCLUDE 'dparam.for'
CHARACTER*(WRDLNT) LBUF(LEXMAX),WORD,LCWORD,LCIFY
CHARACTER*(WRDLNT+2) LCWRD1
LOGICAL LIT,DFLAG,VBFLAG,ANDFLG,BUNFLG
INTEGER OBJVEC(2),PRPVEC(2)
EQUIVALENCE (OBJVEC(1),OBJ1),(PRPVEC(1),PREP1)
C SPARSE, PAGE 2
C
C Vocabularies
C
C Buzz words-- ignored in syntactic processing
C
DATA BWORD/'BY','IS','A','AN','THE',
1'TODAY','MY','YOUR','OUR','HIS'/
C
C Prepositions-- maps prepositions to indices
C
DATA PWORD/'OVER','WITH','USING','AT','TO',
1'IN','INSIDE','INTO','DOWN','UP',
2'UNDER','OF','ON','OFF','FOR',
3'FROM','OUT','THROUGH',' ',' '/
C
DATA PVOC/1,2,2,3,4,
15,5,5,6,7,
28,9,10,11,12,
313,13,14,0,0/
C
C Directions-- maps directions to indices
C
DATA DWORD/'N','NORTH','S','SOUTH',
1'E','EAST','W','WEST',
2'SE','SW','NE','NW',
4'U','UP','D','DOWN',
5'LAUNCH','LAND','EXIT','OUT',
6'TRAVEL','IN','CROSS',' ',' '/
C
DATA DVOC/XNORTH,XNORTH,XSOUTH,XSOUTH,
1XEAST,XEAST,XWEST,XWEST,
2XSE,XSW,XNE,XNW,
4XUP,XUP,XDOWN,XDOWN,
5XLAUN,XLAND,XEXIT,XEXIT,
6XCROSS,XENTER,XCROSS,0,0/
C SPARSE, PAGE 3
C
C Adjectives-- maps adjectives to object numbers
C
C Each string entry in aword corresponds to a list of one or more
C object numbers in AVOC. Object entries are delimited by the first
C object being positive, and all subsequent objects in the same entry
C being negative.
C
DATA (AWORD(I),I=1,40) /
1'BROWN','ELONGATE','HOT','PEPPER',
1'VITREOUS','JADE','HUGE','ENORMOUS',
2'TROPHY','CLEAR','LARGE','NASTY',
3'ELVISH','BRASS','BROKEN','ORIENTAL',
4'BLOODY','RUSTY','BURNED-O','DEAD',
5'OLD','LEATHER','PLATINUM','PEARL',
6'MOBY','CRYSTAL','GOLD','IVORY',
7'SAPPHIRE','WOODEN','WOOD','STEEL',
8'DENTED','FANCY','ANCIENT','SMALL',
9'BLACK','TOUR','VISCOUS','VICIOUS'/
C
DATA (AVOC(I),I=1,112) /
11,-81,-133,1,3,-190,3,
14,6,8,8,-122,
29,10,12,-26,-47,-95,-96,-123,-133,-135,-144,-145,
2-150,-176,-191,13,-19,
314,15,-16,-46,-156,-190,16,-22,-38,-92,-113,-155,-158,17,
420,24,-205,22,22,
525,-41,-44,-45,-208,25,26,27,
631,32,-126,-206,-209,33,-85,-104,-157,-158,-188,34,
737,38,-67,-75,-93,-136,-137,-165,-173,-174,-175,-197,-204,
738,-67,-136,-137,-165,-173,-174,-175,
739,-105,-124,-125,-189,
839,40,41,-44,5,-46,-52,-53,-89,-102,-103,-153,-187,
947,-162,49,55,62/
C
DATA (AWORD(I),I=41,80) /
1'GLASS','TRAP','FRONT','STONE',
1'MANGLED','RED','YELLOW','BLUE',
2'VAMPIRE','MAGIC','SEAWORTH','TAN',
3'SHARP','WICKER','CLOTH','BRAIDED',
4'GAUDY','SQUARE','CLAY','SHINY',
5'THIN','GREEN','PURPLE','WHITE',
6'MARBLE','COKE','EMPTY','ROUND',
7'TRIANGUL','RARE','OBLONG','EAT-ME',
8'EATME','ORANGE','ECCH','ROCKY',
9'SHEER','200','NEAT','SHIMMERI'/
C
DATA (AVOC(I),I=113,179) /
110,-126,-132,-206,-209,66,68,69,-150,-278,
1 72,-124,79,-94,-140,-161,-170,-171,-190,-209,
180,-159,82,-112,-114,-141,-206,
283,90,-281,90,91,
392,98,100,101,
4108,109,-127,109,110,
5110,77,-115,-143,116,117,-126,-147,-160,-266,
6119,121,121,128,
7129,134,135,138,
8138,139,141,146,
9146,148,148,151/
C
DATA (AWORD(I),I=81,120) /
1'ZURICH','BIRDS','ENCRUSTE','BEAUTIFU',
1'CLOCKWOR','MECHANIC','MAHOGANY','PINE',
2'LONG','CENTER','SHORT','T',
3'COMPASS','BRONZE','CELL','LOCKED',
4'SUN','BARE','SONG','NORTH',
5'NORTHERN','SOUTH','SOUTHERN','EAST',
6'EASTERN','WEST','WESTERN','DUNGEON',
7'FREE','GRANITE','LOWERED','VOLCANO',
8'MAN-SIZE','METAL','PLASTIC','SILVER',
9'USED','USELESS','SEEING','ONE-EYED'/
C
DATA (AVOC(I),I=180,238) /
1152,153,-154,-155,154,-155,86,-156,
1157,-158,157,-158,163,164,
2166,166,167,168,
3169,-275,172,174,-175,174,
4177,259,267,269,
5269,270,270,271,
6271,67,-272,67,-272,279,
7195,-262,265,36,111,
893,64,-99,-200,-201,77,-87,-88,-90,59,
922,22,126,-206,-209,58/
C
DATA (AWORD(I),I=121,160) /
1'HOLY','HAND-HEL','UNRUSTY','PLAIN',
1'PRICELES','SANDY','GIGANTIC','LINE-PRI',
2'FLATHEAD','FINE','SHADY','SUSPICIO',
3'CROSS','TOOL','CONTROL','DON',
4'WOODS','GOLDEN','OAK','BARRED',
5'DUSTY','NARROW','IRON','WELCOME',
6'RUBBER','SKELETON','ALL','ZORKMID',
712*' '/
C
DATA (AVOC(I),I=239,282) /
143,89,13,13,
1104,192,122,122,
2118,91,61,61,
3165,193,194,196,
4196,157,-158,197,198,-210,
5204,199,205,207,
6207,23,253,-254,104,-148,
712*0/
C SPARSE, PAGE 4
C
C OBJECTS-- Maps objects to object indices,
C same format as AVOC.
C
DATA (OWORD(I),I=1,40) /
1'BAG','SACK','GARLIC','CLOVE',
1'FOOD','SANDWICH','LUNCH','DINNER',
2'GUNK','PIECE','SLAG','COAL',
3'PILE','HEAP','FIGURINE','MACHINE',
4'PDP10','VAX','DRYER','LID',
5'DIAMOND','CASE','BOTTLE','CONTAINE',
6'WATER','QUANTITY','LIQUID','H2O',
7'ROPE','HEMP','COIL','KNIFE',
8'BLADE','SWORD','ORCHRIST','GLAMDRIN',
9'LAMP','LANTERN','RUG','CARPET'/
C
DATA (OVOC(I),I=1,71) /
11,-25,-100,1,2,2,
13,3,3,3,
24,-55,4,-143,-186,-282,4,5,
35,-18,-38,-72,-73,-87,-88,-122,-148,5,6,7,
47,7,7,7,-200,-201,
58,9,-123,10,-121,10,
611,-273,11,-273,11,-273,11,-273,
712,-101,-282,12,12,-110,13,-24,
813,-14,14,14,14,
915,-16,-22,15,-16,-22,17,17/
C
DATA (OWORD(I),I=41,80) /
1'LEAVES','LEAF','TROLL','AXE',
1'PRAYER','KEYS','KEY','SET',
2'BONES','SKELETON','BODY','COINS',
3'BAR','NECKLACE','PEARLS','MIRROR',
4'ICE','MASS','GLACIER','RUBY',
5'TRIDENT','FORK','COFFIN','CASKET',
6'TORCH','CAGE','DUMBWAIT','BASKET',
7'BRACELET','JEWEL','TIMBER','BOX',
8'STRADIVA','VIOLIN','ENGRAVIN','INSCRIPT',
9'GHOST','SPIRIT','FIEND','GRAIL'/
C
DATA (OVOC(I),I=72,130) /
118,18,19,-111,20,
144,-47,23,23,-205,23,
221,21,21,-72,-73,25,
326,-165,-168,27,27,28,-29,-276,
430,30,30,31,
532,32,33,33,
634,35,-36,-124,-125,35,-36,35,-36,-98,-113,
737,37,38,39,-53,-105,
840,40,41,41,-44,
942,42,42,43/
C
DATA (OWORD(I),I=81,120) /
1'TRUNK','CHEST','BELL','BOOK',
1'BIBLE','GOODBOOK','CANDLES','PAIR',
2'GUIDEBOO','GUIDE','PAPER','NEWSPAPE',
3'ISSUE','REPORT','MAGAZINE','NEWS',
4'MATCHBOO','MATCH','MATCHES','ADVERTIS',
5'PAMPHLET','LEAFLET','BOOKLET','MAILBOX',
6'TUBE','TOOTHPAS','PUTTY','MATERIAL',
7'GLUE','WRENCH','SCREWDRI','CYCLOPS',
8'MONSTER','CHALICE','CUP','GOBLET',
9'PAINTING','ART','CANVAS','PICTURE'/
C
DATA (OVOC(I),I=131,182) /
145,45,-193,46,-190,47,-49,-114,-115,-116,-117,
147,47,48,48,
249,49,50,-122,-143,-186,50,
350,50,50,50,
451,51,51,52,
552,52,52,53,
654,54,55,55,
755,56,57,58,
858,59,59,59,
960,-149,60,-149,60,60/
C
DATA (OWORD(I),I=121,160) /
1'WORK','MASTERPI','THIEF','ROBBER',
1'CRIMINAL','BANDIT','CROOK','GENT',
2'GENTLEMA','MAN','INDIVIDU','BAGMAN',
3'STILETTO','WINDOW','BOLT','NUT',
4'GRATE','GRATING','DOOR','TRAP-DOO',
5'SWITCH','HEAD','CORPSE','BODIES',
6'DAM','GATES','GATE','FCD',
7'RAIL','RAILING','BUTTON','BUBBLE',
8'LEAK','DRIP','HOLE','BAT',
9'RAINBOW','POT','STATUE','SCULPTUR'/
C
DATA (OVOC(I),I=183,258) /
160,60,61,61,
161,61,61,61,
261,61,61,61,
362,63,-198,-210,64,64,
465,65,66,-67,-68,-69,-119,-164,
4-172,-173,-174,-175,-189,-197,66,
570,-79,-80,-81,-82,-170,71,-120,72,-73,72,-73,
674,74,-76,74,-76,74,
775,75,76,-79,-80,-81,-82,-127,-128,-129,-170,-176,77,
878,-191,78,78,-107,-202,-203,83,
984,85,86,86/
C
DATA (OWORD(I),I=161,200) /
1'ROCK','BOAT','PLASTIC','PUMP',
1'AIRPUMP','AIR-PUMP','LABEL','FINEPRIN',
2'STICK','BARREL','BUOY','EMERALD',
3'SHOVEL','GUANO','CRAP','SHIT',
4'HUNK','BALLOON','RECEPTAC','WIRE',
5'HOOK','ZORKMID','COIN','SAFE',
6'CARD','NOTE','SLOT','CROWN',
7'BRICK','FUSE','GNOME','STAMP',
8'TOMB','CRYPT','GRAVE','HEADS',
9'POLES','IMPLEMEN','LOSERS','COKES'/
C
DATA (OVOC(I),I=259,312) /
186,87,-88,-90,87,-88,-90,89,
189,89,91,-112,91,
292,93,94,95,
396,97,97,97,
497,98,-113,99,101,-110,
5102,-103,104,-148,104,105,
6106,-188,106,-186,107,-187,108,
7109,110,111,-152,118,-196,
8119,119,119,120,
9120,120,120,121/
C
DATA (OWORD(I),I=201,240) /
1'LISTINGS','OUTPUT','PRINTOUT','SPHERE',
1'BALL','ETCHING','WALLS','WALL',
2'FLASK','POOL','SEWAGE','TIN',
3'SAFFRON','SPICES','TABLE','POST',
4'POSTS','BUCKET','CAKE','ICING',
5'ROBOT','ROBBY','C3PO','R2D2',
6'PANEL','POLE','TBAR','T-BAR',
7'ARROW','POINT','BEAM','DIAL',
8'SUNDIAL','1','ONE','2',
9'TWO','3','THREE','4'/
C
DATA (OVOC(I),I=313,387) /
1122,122,122,126,-206,-209,
1126,130,-131,130,-131,-257,130,-131,-159,
1-160,-161,-162,-163,-164,-257,-265,-269,-270,-271,-272,
2132,133,133,134,
3134,134,135,-204,136,-166,-167,
4136,137,138,-139,-140,-141,139,-140,-141,
5142,142,142,142,
6159,-160,-161,-162,-163,-164,-194,-277,120,-166,-167,168,168,
7169,169,171,177,
8177,178,178,179,
9179,180,180,181/
C
DATA (OWORD(I),I=241,280) /
1'FOUR','5','FIVE','6',
1'SIX','7','SEVEN','8',
2'EIGHT','WARNING','SLIT','IT',
3'THAT','THIS','ME','MYSELF',
4'CRETIN','ALL','EVERYTHI','TREASURE',
5'VALUABLE','SAILOR','TEETH','GRUE',
6'HAND','HANDS','LUNGS','AIR',
7'AVIATOR','FLYER','TREE','CLIFF',
8'LEDGE','PORTRAIT','STACK','BILLS',
9'VAULT','CUBE','LETTERIN','CURTAIN'/
C
DATA (OVOC(I),I=388,432) /
1181,182,182,183,
1183,184,184,185,
2185,186,187,250,
3250,250,251,251,
4251,252,252,253,
5253,255,256,258,
6259,259,260,260,
7261,261,144,-145,-268,146,-147,
8146,149,122,-148,148,
9150,150,67,-150,151/
C
DATA (OWORD(I),I=281,320) /
1'LIGHT','NEST','EGG','BAUBLE',
1'CANARY','BIRD','SONGBIRD','GUARD',
2'GUARDIAN','ROSE','STRUCTUR','CHANNEL',
3'KEEPER','LADDER','BROCHURE','WISH',
4'GROUND','EARTH','SAND','WELL',
5'SLIDE','CHUTE','HOUSE','BOTTLES',
6'BUNCH','PALANTIR','STONE','FLINT',
7'POSSESSI','GOOP','BEACH','GRIP',
8'HANDGRIP','PRINT','ETCHINGS','CRACK',
9'KEYHOLE','MAT','STOVE','PLATINUM'/
C
DATA (OVOC(I),I=433,485) /
115,-151,-171,153,154,-155,156,
1157,-158,267,267,274,
2274,275,276,278,
3279,280,195,-262,263,
4264,264,192,-264,281,
5283,283,266,121,
6121,126,-206,-209,126,-206,-209,51,
7254,133,192,167,
8167,91,-122,130,-131,199,
9202,-203,207,208,26/
C
DATA (OWORD(I),I=321,360) /
1'HIM','SELF','GOLD','SAPPHIRE',
1'IVORY','MASTER','CANDLE','JADE',
2'SCREEN','BLESSING','GHOSTS','SPIRITS',
3'CORPSES','JEWELS','CLIFFS','CHIMNEY',
424*' '/
C
DATA (OVOC(I),I=486,529) /
1250,251,85,-104,37,
134,279,48,6,
2151,263,42,42,
372,-73,37,-45,146,-147,211,
424*0/
C SPARSE, PAGE 5
C
C VERBS-- Maps verbs to syntax slots
C
C Vocabulary entries are variable length and consist of one
C or more words. If an entry contains more than one word,
C all but the last are prefaced with an '*'. The preferred
C string for error messages should be first.
C
C Syntax entries consist of a flag word followed by 0, 1, or 2
C Object descriptions. The flag word has the following format--
C
C bit <14> if 1, syntax includes direct object
C bit <13> if 1, syntax includes indirect object
C bit <12> if 1, direct object is implicit (standard form)
C bit <11> if 1, direct and indirect object must be swapped
C after syntax processing
C bit <10> if 1, this is default syntax for orphanery
C bits <8:0> verb number for VAPPLI
C
C Object descriptions consist of a flag word and two FWIM words.
C The flag word has the following format--
C
C bit <14> if 1, search adventurer for object
C bit <13> if 1, search room for object
C bit <12> if 1, parser will try to take object
C bit <11> if 1, adventurer must have object
C bit <10> if 1, qualifying bits (normally -1,-1) are same
C as FWIM bits
C bit <9> if 1, object must be reachable
C bits <8:0> preposition number for SYNMCH
C
C The FWIM words have the same format as the two object flag words.
C
C Note that bits 12 and 11 of object descriptions actually have
C four distinct states--
C
C bit 12 bit 11 mdldesc interpretation
C ------ ------ ------- ---------------
C
C 0 0 -- no parser action
C 0 1 HAVE adventurer must have object
C 1 0 TRY try to take, dont care if fail
C 1 1 TAKE try to take, care if fail
C
C SPARSE, PAGE 6
C
DATA (VWORD(I),I=1,43) /
1'BRIEF','VERBOSE','SUPERBRI','STAY',
1'VERSION','*SWIM','*BATHE','WADE',
2'GERONIMO','*ULYSSES','ODYSSEUS','*PLUGH','XYZZY',
3'PRAY','TREASURE','TEMPLE','BLAST',
4'SCORE','*QUIT','*GOODBYE','*Q','BYE','HELP',
5'INFO','*HISTORY','UPDATE','BACK',
6'*MUMBLE','SIGH','*CHOMP','*LOSE',
7'BARF','DUNGEON','FROBOZZ','*FOO',
8'*BLETCH','BAR','REPENT','*HOURS',
9'SCHEDULE','WIN','*YELL','*SCREAM'/
C
DATA (VVOC(I),I=1,54) /
11,70,1,71,1,72,1,73,
11,74,1,75,
21,76,1,77,1,56,
31,79,1,80,1,81,1,82,
41,83,1,84,1,40,
51,41,1,42,1,43,
61,44,
71,45,1,46,1,47,
81,48,1,49,
91,50,1,51/
C
DATA (VWORD(I),I=44,86) /
1'SHOUT','*HOP','SKIP','*CURSE',
1'*SHIT','*DAMN','FUCK','ZORK',
2'WISH','SAVE','RESTORE','TIME',
3'DIAGNOSE','EXORCISE','*LIST','*I','INVENTOR',
4'WAIT','INCANT','*ANSWER','RESPOND','AGAIN',
5'NOOBJ','*BUG','*GRIPE','COMPLAIN',
6'*FEATURE','*COMMENT','*IDEA','SUGGESTI',
7'ROOM','*OBJECTS','OBJ','RNAME','DEFLATE',
8'*EXAMINE','*WHAT','DESCRIBE','FILL',
9'*FIND','*SEEK','*WHERE','SEE'/
C
DATA (VVOC(I),I=55,120) /
11,52,1,53,
11,54,1,55,
21,169,1,149,1,150,1,90,
31,94,1,105,1,133,
41,128,1,95,1,96,1,57,
51,58,1,59,
61,60,
71,65,1,66,1,67,1,8#50147,
84,8#40170,8#60000,-1,-1,
811,8#60206,8#61000,8#200,0,8#61002,-1,-1,
88#40206,8#61000,8#200,0,
94,8#40177,8#60000,-1,-1/
C
DATA (VWORD(I),I=87,131) /
1'FOLLOW','*KICK','*BITE','TAUNT',
1'LOWER','*PUSH','PRESS','*RING',
2'PEAL','*RUB','*FEEL','*CARESS','*TOUCH',
3'FONDLE','SHAKE','SPIN','*UNTIE',
4'FREE','*WALK','*RUN','*PROCEED','GO','*ATTACK','*FIGHT',
5'*INJURE','*HIT','HURT','BOARD',
6'*BRUSH','CLEAN','*BURN','*IGNITE',
7'INCINERA','CLIMB','CLOSE','DIG',
8'DISEMBAR','*DRINK','*IMBIBE','SWALLOW',
9'*DROP','RELEASE','*EAT','*GOBBLE','*CONSUME'/
C
DATA (VVOC(I),I=121,278) /
12,8#125,8#50125,1,8#50153,
11,8#50156,9,8#50160,8#40160,8#61012,-1,-1,
18#40241,8#61010,-1,-1,
25,8#52127,8#70127,8#61002,-1,-1,
31,8#50157,1,8#50171,1,8#50201,
411,8#42161,8#61000,0,8#10000,
48#60242,8#61000,0,8#10000,8#61015,-1,-1,
49,8#50216,8#40126,8#61016,-1,-1,8#40126,8#61005,-1,-1,
57,8#60215,8#21000,0,8#200,8#44002,0,8#1000,
54,8#40202,8#21000,0,2,
65,8#52130,8#70130,8#61002,-1,-1,
77,8#60211,8#61000,8#20,0,8#64002,8#10,0,
712,8#40235,8#20007,0,8#4000,8#40236,8#20006,0,8#4000,
78#40234,8#20000,0,8#4000,
74,8#40176,8#61000,8#10200,0,
721,8#60131,8#20005,0,8#40000,8#44002,4,0,
7 8#60131,8#20016,0,8#40000,8#44002,4,0,
7 8#60131,8#20000,0,8#40000,8#44002,4,0,
88,8#40203,8#20000,0,2,8#40203,8#20015,0,2,
84,8#40210,8#61000,8#400,0,
925,8#42221,8#41000,-1,-1,
98#60220,8#41000,-1,-1,8#61005,-1,-1,
98#60220,8#41000,-1,-1,8#61006,-1,-1,
98#60220,8#41000,-1,-1,8#61016,-1,-1/
C
DATA (VWORD(I),I=132,172) /
1'*MUNCH','TASTE','*DOUSE','EXTINGUI',
1'*GIVE','*HAND','DONATE','*HELLO',
2'HI','BLOW','INFLATE','*JUMP',
3'LEAP','*KILL','*MURDER','*SLAY',
4'*STAB','DISPATCH','*KNOCK','RAP',
5'LIGHT','LOCK','*LOOK','*L','*STARE',
6'GAZE','*MELT','LIQUIFY','MOVE',
7'*PULL','TUG','*DESTROY','*MUNG',
8'*BREAK','DAMAGE','OPEN','PICK',
9'*PLUG','*GLUE','PATCH','*POKE'/
C
DATA (VVOC(I),I=279,450) /
14,8#40207,8#75000,8#2000,0,
14,8#40174,8#75000,8#100,0,
111,8#72222,8#21004,8#40,0,8#64222,8#21000,8#40,0,
18#61000,-1,-1,
22,8#2227,8#50227,
215,8#62146,8#61007,-1,-1,8#61002,4,0,
28#40122,8#61007,-1,-1,8#40165,8#61005,-1,-1,
24,8#70146,8#61002,4,0,
35,8#133,8#40133,8#61001,-1,-1,
47,8#60213,8#21000,0,8#200,8#44002,0,8#1000,
412,8#42166,8#61003,-1,-1,8#40166,8#61012,-1,-1,
48#40215,8#23006,8#40,0,
511,8#42173,8#75000,8#100,0,8#60211,8#61000,8#100,0,
58#54002,8#10,0,
57,8#60134,8#20000,-1,-1,8#74002,4,0,
631,8#167,8#40170,8#60003,-1,-1,8#40231,8#61010,-1,-1,
68#40230,8#60005,-1,-1,8#40230,8#60016,-1,-1,
68#60144,8#60003,-1,-1,8#61002,-1,-1,
68#60144,8#60003,-1,-1,8#61016,-1,-1,
64,8#70145,8#61002,8#10,0,
64,8#40172,8#20000,-1,-1,
78,8#42172,8#21000,-1,-1,8#40172,8#21012,-1,-1,
85,8#52212,8#70212,8#44002,-1,-1,
811,8#42175,8#61000,8#10200,0,8#60175,8#61000,8#10200,0,
88#54002,4,8#1000,
84,8#40204,8#61007,8#20000,8#40,
94,8#70152,8#61002,-1,-1/
C
DATA (VWORD(I),I=173,212) /
1'*BLIND','JAB','*POUR','SPILL',
1'PUMP','*PUT','*INSERT','*STUFF',
2'PLACE','*RAISE','LIFT','*READ',
3'*PERUSE','SKIM','STRIKE','*SWING',
4'THRUST','*TAKE','*HOLD','*CARRY',
5'REMOVE','*TELL','*COMMAND','REQUEST',
6'*THROW','*HURL','CHUCK','*TIE',
7'FASTEN','*TURN','SET','UNLOCK',
8'*WAKE','*ALARM','*STARTLE','SURPRISE',
9'*WAVE','*FLAUNT','BRANDISH','WIND'/
C
DATA (VVOC(I),I=451,654) /
17,8#60212,8#21000,0,8#200,8#44002,0,8#1000,
125,8#42223,8#41000,8#400,0,
18#60223,8#41000,8#400,0,8#61005,-1,-1,
18#60223,8#41000,8#400,0,8#61016,-1,-1,
18#60240,8#41000,8#400,0,8#61012,-1,-1,
14,8#60232,8#60007,-1,-1,
216,8#72220,8#61005,-1,-1,8#70220,8#61016,-1,-1,
28#40221,8#61006,-1,-1,8#70241,8#61010,-1,-1,
25,8#52155,8#40155,8#61007,-1,-1,
318,8#42144,8#71000,8#40000,0,
38#60144,8#71000,8#40000,0,8#61002,-1,-1,
38#60144,8#71000,8#40000,0,8#61016,-1,-1,
312,8#60215,8#23000,8#40,0,8#44002,0,8#1000,
38#42215,8#23000,8#40,0,8#50173,
47,8#60214,8#44000,0,8#1000,8#21003,0,8#200,
511,8#42204,8#61000,8#20000,8#40,
58#60204,8#61000,8#20000,0,8#61015,-1,-1,
54,8#40217,8#20000,0,8#2000,
621,8#62224,8#44000,-1,-1,8#21003,8#40,0,
68#60224,8#44000,-1,-1,8#21016,8#40,0,
68#60220,8#44000,-1,-1,8#61005,-1,-1,
711,8#70162,8#61004,-1,-1,8#60163,8#21007,8#40,0,
78#65002,4,0,
722,8#62164,8#61000,2,0,8#64002,4,0,
78#40173,8#75012,8#100,0,8#40174,8#75013,8#100,0,
78#60237,8#61000,2,0,8#20004,-1,-1,
77,8#60135,8#21000,-1,-1,8#74002,4,0,
88,8#42150,8#20000,8#40,0,8#40150,8#20007,8#40,0,
94,8#40154,8#40000,-1,-1,
95,8#50233,8#40233,8#61007,-1,-1/
C
DATA (VWORD(I),I=213,240)/
1'ENTER','LEAVE','*MAKE','BUILD',
1'*OIL','*GREASE','LUBRICAT','PLAY',
2'SEND','SLIDE','*SMELL','SNIFF',
3'SQUEEZE','GET','COUNT',13*' '/
C
DATA (VVOC(I),I=655,722) /
12,167,8#50126,2,168,8#50220,1,8#50243,
14,8#70244,8#41002,-1,-1,
15,8#50245,8#70245,8#75002,4,0,
24,8#40246,8#61014,-1,-1,
24,8#70241,8#61010,-1,-1,1,8#50105,
31,8#50104,19,8#42204,8#61000,8#20000,8#40,
38#40202,8#21005,0,2,8#40203,8#21015,0,2,
38#60204,8#61000,8#20000,8#40,8#61015,-1,-1,
31,8#50141,13*0/
C SPARSE, PAGE 7
C
C Set up for parsing
C
SPARSE=-1 ! assume parse fails.
ADJ=0 ! clear parts holders.
ACT=0
PREP=0
PPTR=0
OBJ1=0
OBJ2=0
PREP1=0
PREP2=0
LOBJ=0
ANDFLG=.FALSE.
BUNFLG=.FALSE.
DFLAG=(PRSFLG.AND.4).NE.0
C SPARSE, PAGE 8
C
C Now loop over input buffer of lexical tokens.
C
I=0
10 I=I+1 ! do 1000 i=1,llnt
WORD=LBUF(I) ! get current token.
ERRVOC=0 ! assume won't find
IF(WORD.EQ.' ') GO TO 1000 ! blank? ignore.
IF(WORD.EQ.'AND') GO TO 1500 ! 'AND'?
IF((WORD.EQ.'EXCEPT').OR.(WORD.EQ.'BUT')) GO TO 2500
C
C Check for buzz word
C
DO 50 J=1,BWMAX
IF(WORD.EQ.BWORD(J)) GO TO 1000 ! if match, ignore.
50 CONTINUE
C
C Check for action or direction
C
J=1 ! check for action.
DO 70 K=1,VWMAX
IF(VWORD(K)(1:1).EQ.'*') GO TO 65 ! synonym?
IF(WORD.EQ.VWORD(K)) GO TO 2000 ! match to base word?
J=J+VVOC(J)+1 ! skip over syntax.
GO TO 70
65 IF(WORD.EQ.VWORD(K)(2:WRDLNT)) GO TO 2000 ! synonym match?
70 CONTINUE
C
75 IF((ADJ.NE.0).OR.(PREP.NE.0).OR.(OBJ1.NE.0)) GO TO 200
IF(ACT.EQ.0) GO TO 80 ! any verb yet?
IF((VVOC(ACT+1).AND.SVMASK).NE.WALKW) GO TO 200 ! walk?
80 DO 100 J=1,DWMAX ! then chk for dir.
IF(WORD.EQ.DWORD(J)) GO TO 3000 ! match to direction?
100 CONTINUE
C
C Not an action, check for preposition, adjective, or object.
C
200 DO 250 J=1,PWMAX ! look for preposition.
IF(WORD.EQ.PWORD(J)) GO TO 4000 ! match to preposition?
250 CONTINUE
C
J=1 ! look for adjective.
DO 350 K=1,AWMAX
IF(WORD.EQ.AWORD(K)) GO TO 5000 ! match to adjective?
300 J=J+1 ! advance to next entry.
IF(AVOC(J).LT.0) GO TO 300 ! found next entry yet?
350 CONTINUE
C
400 J=1 ! look for object.
DO 550 K=1,OWMAX
IF(WORD.EQ.OWORD(K)) GO TO 6000 ! match to object?
500 J=J+1 ! advance to next entry.
IF(OVOC(J).LT.0) GO TO 500 ! found next entry yet?
550 CONTINUE
C
C Not recognizable
C
IF(.NOT.VBFLAG) RETURN ! if mute, return
LCWORD=LCIFY(WORD,1) ! convert to lower case
WRITE(OUTCH,600) LCWORD(1:NBLEN(LCWORD)) ! don't recognize
600 FORMAT(' I don''t understand "',A,'".')
CALL RSPEAK(ERRVOC) ! if extra verb, say so
800 TELFLG=.TRUE. ! something said.
BUNSUB=0 ! no valid EXCEPT clause.
RETURN
C SPARSE, PAGE 9
C
1000 IF(I.LT.LLNT) GO TO 10 ! end of do loop
C
C At end of parse, check for:
C 1. dangling adjective
C 2. bunched object
C 3. simple directions
C 4. orphan preposition
C 5. dangling preposition
C
IF(ADJ.NE.0) GO TO 4500 ! dangling adjective?
IF(BUNFLG) OBJ1=BUNOBJ ! bunched object?
IF(BUNFLG.AND.(BUNSUB.NE.0).AND.(BUNLNT.EQ.0))
1GO TO 13200 ! except for nothing?
IF(ACT.EQ.0) ACT=OFLAG.AND.OACT ! if no action, take orphan.
IF(ACT.EQ.0) GO TO 10000 ! no action, punt.
IF(((VVOC(ACT+1).AND.SVMASK).NE.WALKW).OR.(OBJ1.LT.XMIN))
1GO TO 1100 ! simple direction?
IF ((OBJ2.NE.0).OR.(PREP1.NE.0).OR.(PREP2.NE.0))
1GO TO 1050 ! no extra junk?
PRSA=WALKW ! yes, win totally.
PRSO=OBJ1
SPARSE=1 ! special return value.
RETURN
C
1050 IF(VBFLAG) CALL RSPEAK(618) ! direction+junk, fail.
GO TO 800 ! clean up state.
C
1100 IF((OFLAG.NE.0).AND.(OPREP.NE.0).AND.(PREP.EQ.0).AND.
1(OBJ1.NE.0).AND.(OBJ2.EQ.0).AND.(ACT.EQ.OACT))
2GO TO 11000
C
IF(PREP.EQ.0) GO TO 1200 ! if dangling prep,
IF(PPTR.EQ.0) GO TO 12000 ! and no object, die;
IF(PRPVEC(PPTR).NE.0) GO TO 12000 ! and prep already, die;
PRPVEC(PPTR)=PREP ! cvt to 'pick up frob'.
1200 SPARSE=0 ! parse succeeds.
IF(DFLAG) WRITE(OUTCH,1310) ACT,OBJ1,OBJ2,PREP1,PREP2
1310 FORMAT(' SPARSE RESULTS- ',5I7)
RETURN
C SPARSE, PAGE 10
C
C 1500-- AND
C
1500 IF(ADJ.NE.0) GO TO 4100 ! dangling adj? treat as obj.
IF((PREP.NE.0).OR.(PPTR.NE.1)) GO TO 8000 ! prep or not dir obj?
ANDFLG=.TRUE. ! flag 'AND'.
GO TO 1000 ! done.
C
C 2000-- Action
C
2000 IF(ACT.EQ.0) GO TO 2100 ! got one already?
ERRVOC=624 ! flag for error report.
GO TO 75 ! try to construe differently.
C
2100 ACT=J ! save index to verb.
OACT=0 ! no orphan.
ANDFLG=.FALSE. ! clear 'AND' flag.
IF(DFLAG) WRITE(OUTCH,2020) J
2020 FORMAT(' SPARSE- ACT AT ',I6)
GO TO 1000 ! done.
C
C 2500-- EXCEPT/BUT
C
2500 IF(ADJ.NE.0) GO TO 4100 ! dangling adjective?
IF(ANDFLG.OR.BUNFLG.OR.(PPTR.NE.1).OR.
1(I.GE.LLNT)) GO TO 13000 ! not in right place?
IF(LBUF(I+1).NE.'FOR') GO TO 2600 ! except for?
I=I+1 ! skip over.
IF(I.GE.LLNT) GO TO 13000 ! out of text?
2600 IF((OBJ1.NE.EVERY).AND.(OBJ1.NE.VALUA).AND.
1 (OBJ1.NE.POSSE)) GO TO 13100 ! "collective" EXCEPT?
ANDFLG=.TRUE. ! force next object
BUNFLG=.TRUE. ! into bunch vector.
BUNLNT=0 ! start at top.
BUNSUB=OBJ1 ! remember collective.
GO TO 1000 ! on to next word.
C
C 3000-- Direction
C Don't need to check for ambiguous use as adjective;
C only possible overlap is north/south/east/west wall;
C and global wall takes is found if no adjective given.
C
3000 OBJ=DVOC(J) ! save direction.
ACT=1 ! find value for action.
3600 IF(VVOC(ACT).EQ.0) CALL BUG(310,ACT) ! can't find walk.
IF((VVOC(ACT+1).AND.SVMASK).EQ.WALKW) GO TO 6300 ! treat as obj.
ACT=ACT+VVOC(ACT)+1 ! to next syntax entry.
GO TO 3600
C
C 4000-- Preposition (or dangling adjective at end of parse)
C
4000 IF(ADJ.EQ.0) GO TO 4600 ! dangling adjective?
4100 I=I-1 ! back up parse stream.
4500 WORD=AWORD(ADJPTR) ! get adjective string.
ADJ=0 ! now an object.
GO TO 400 ! go search object words.
C
4600 IF(ANDFLG) GO TO 8000 ! 'AND' pending?
IF(PREP.NE.0) GO TO 1000 ! already have one? ignore.
PREP=PVOC(J) ! no, get index.
IF(DFLAG) WRITE(OUTCH,4030) J
4030 FORMAT(' SPARSE- PREP AT ',I6)
GO TO 1000
C
C 5000-- Adjective
C
5000 ADJ=J ! save adjective.
ADJPTR=K ! save string pointer.
IF((I.LT.LLNT).OR.(OFLAG.EQ.0).OR.(ONAME.EQ.' '))
1GO TO 1000 ! last word + orphan string?
IF(DFLAG) WRITE(OUTCH,5040) ADJ,ONAME ! have orphan.
5040 FORMAT(' SPARSE- ADJ AT ',I6,' ORPHAN= ',A)
WORD=ONAME ! get object string.
GO TO 400 ! go search object names.
C
C 6000-- Object
C
6000 OBJ=GETOBJ(J,ADJ,0) ! identify object.
IF(DFLAG) WRITE(OUTCH,6010) J,OBJ
6010 FORMAT(' SPARSE- OBJ AT ',I6,' OBJ= ',I6)
IF(OBJ.LE.0) GO TO 7000 ! if le, couldnt.
IF(OBJ.NE.ITOBJ) GO TO 6100 ! "it"?
IF((OFLAG.AND.OOBJ1).NE.0) LASTIT=OFLAG.AND.OOBJ1 ! orphan?
OBJ=GETOBJ(0,0,LASTIT) ! find it.
IF(OBJ.LE.0) GO TO 7500 ! if le, couldnt.
C
6100 IF(PREP.NE.9) GO TO 6200 ! "of" obj?
IF((LOBJ.EQ.OBJ).OR.(LOBJ.EQ.OCAN(OBJ))) GO TO 6500 ! same as prev?
IF((LOBJ.EQ.EVERY).AND.((OBJ.EQ.VALUA).OR.(OBJ.EQ.POSSE)))
1GO TO 6350 ! all of "collective"?
6150 IF(VBFLAG) CALL RSPEAK(601) ! doesn't work
GO TO 800 ! clean up state.
C
6200 IF(.NOT.ANDFLG) GO TO 6300 ! 'AND' pending?
IF(BUNFLG) GO TO 6250 ! first object?
BUNVEC(1)=OBJVEC(PPTR) ! put preceding obj in vector.
BUNLNT=1
BUNFLG=.TRUE. ! flag bunch of objects.
BUNSUB=0 ! no EXCEPT/BUT clause.
6250 BUNLNT=BUNLNT+1 ! advance bunch pointer.
IF(BUNLNT.GT.BUNMAX) GO TO 9000 ! too many objects?
BUNVEC(BUNLNT)=OBJ ! add to bunch vector.
GO TO 6500
C
6300 IF(PPTR.EQ.2) GO TO 9000 ! too many objs?
PPTR=PPTR+1
PRPVEC(PPTR)=PREP
6350 OBJVEC(PPTR)=OBJ ! stuff into vector.
6500 PREP=0
ADJ=0
ANDFLG=.FALSE. ! no pending 'AND'.
LOBJ=OBJ ! record last object.
GO TO 1000
C SPARSE, PAGE 11
C
C 7000-- Unidentifiable object (index into OVOC is J)
C
7000 LCWORD=LCIFY(WORD,1) ! convert obj to lower case.
LCWRD1=' ' ! assume no adjective
IF(ADJ.NE.0) LCWRD1=' '//LCIFY(AWORD(ADJPTR),1)//' '
IF(OBJ.LT.0) GO TO 7200 ! ambiguous or unreachable?
IF(LIT(HERE)) GO TO 7100 ! lit?
IF(VBFLAG) CALL RSPEAK(579) ! not lit, report.
GO TO 800 ! go clean up state.
C
7100 IF(VBFLAG) WRITE(OUTCH,7110)
1LCWRD1(1:NBLEN(LCWRD1)+1),LCWORD(1:NBLEN(LCWORD))
7110 FORMAT(' I can''t see any',A,A,' here.')
GO TO 800 ! go clean up state.
C
7200 IF(OBJ.NE.-10000) GO TO 7300 ! inside vehicle?
IF(VBFLAG) CALL RSPSUB(620,ODESC2(AVEHIC(WINNER)))
GO TO 800 ! go clean up state.
C
7300 IF(ACT.EQ.0) ACT=OFLAG.AND.OACT ! if no act, get orphan.
CALL ORPHAN(-1,ACT,PREP1,OBJ1,PREP,WORD,0,0) ! orphan the world.
IF(VBFLAG) WRITE(OUTCH,7310)
1LCWRD1(1:NBLEN(LCWRD1)+1),LCWORD(1:NBLEN(LCWORD))
7310 FORMAT(' Which',A,A,' do you mean?')
GO TO 800 ! go clean up state.
C
C 7500-- Unidentifiable 'IT' (last direct object is LASTIT).
C
7500 IF(OBJ.LT.0) GO TO 7200 ! if lt, must be unreachable.
IF(LIT(HERE)) GO TO 7600 ! lit?
IF(VBFLAG) CALL RSPEAK(1076) ! lose.
GO TO 800 ! go clean up state.
C
7600 IF(VBFLAG) CALL RSPSUB(1077,ODESC2(LASTIT)) ! don't see it.
GO TO 800 ! go clean up state.
C
C 8000-- Misplaced 'AND'.
C
8000 IF(VBFLAG) CALL RSPEAK(1049)
GO TO 800 ! go clean up state.
C
C 9000-- Too many objects.
C
9000 IF(VBFLAG) CALL RSPEAK(617)
GO TO 800 ! go clean up state.
C
C 10000-- No action, punt.
C
10000 IF(OBJ1.EQ.0) GO TO 10100 ! any direct object?
IF(VBFLAG) CALL RSPSUB(621,ODESC2(OBJ1)) ! what to do?
CALL ORPHAN(-1,0,PREP1,OBJ1,0,' ',0,0)
RETURN
C
10100 IF(VBFLAG) CALL RSPEAK(622) ! huh?
GO TO 800 ! go clean up state.
C
C 11000-- Orphan preposition. Conditions are
C OBJ1.NE.0, OBJ2=0, PREP=0, ACT=OACT
C
11000 IF(OOBJ1.NE.0) GO TO 11500 ! orphan object?
PREP1=OPREP ! no, just use prep.
GO TO 1200
C
11500 OBJ2=OBJ1 ! yes, use as direct obj.
PREP2=OPREP
OBJ1=OOBJ1
PREP1=OPREP1
GO TO 1200
C
C 12000-- True hanging preposition, no objects yet.
C
12000 CALL ORPHAN(-1,ACT,0,0,PREP,' ',0,0) ! orphan prep.
GO TO 1200
C
C 13000-- EXCEPT/BUT errors.
C
13000 LCWORD=LCIFY(WORD,1)
IF(VBFLAG) WRITE(OUTCH,13010) LCWORD(1:NBLEN(LCWORD)) ! wrong place.
13010 FORMAT(' Misplaced "',A,'".')
GO TO 800 ! go clean up state.
C
13100 LCWORD=LCIFY(WORD,2) ! wrong case.
IF(VBFLAG) WRITE(OUTCH,13110) LCWORD(1:NBLEN(LCWORD)) ! not coll.
13110 FORMAT(' "',A,'" can only be used with "everything",',
1' "valuables", or "possessions".')
GO TO 800 ! go clean up state.
C
13200 IF(VBFLAG) CALL RSPEAK(619) ! no objects.
GO TO 800 ! go clean up state.
C
END
C GETOBJ-- Find obj described by adj, name pair
C
C Declarations
C
C This routine details on bit 3 of PRSFLG
C
INTEGER FUNCTION GETOBJ(OIDX,AIDX,SPCOBJ)
IMPLICIT INTEGER(A-Z)
INCLUDE 'dparam.for'
LOGICAL THISIT,GHERE,LIT,CHOMP,DFLAG,NOADJS
C
DFLAG=(PRSFLG.AND.8).NE.0
CHOMP=.FALSE.
AV=AVEHIC(WINNER)
OBJ=0 ! assume dark.
IF(.NOT.LIT(HERE)) GO TO 200 ! lit?
C
OBJ=SCHLST(OIDX,AIDX,HERE,0,0,SPCOBJ) ! search room.
IF(DFLAG) WRITE(OUTCH,10) OBJ
10 FORMAT(' SCHLST- ROOM SCH ',I6)
IF(OBJ) 1000,200,100 ! test result.
100 IF((AV.EQ.0).OR.(AV.EQ.OBJ).OR.(OCAN(OBJ).EQ.AV).OR.
1((OFLAG2(OBJ).AND.FINDBT).NE.0)) GO TO 200
CHOMP=.TRUE. ! not reachable.
C
200 IF(AV.EQ.0) GO TO 400 ! in vehicle?
NOBJ=SCHLST(OIDX,AIDX,0,AV,0,SPCOBJ) ! search vehicle.
IF(DFLAG) WRITE(OUTCH,220) NOBJ
220 FORMAT(' SCHLST- VEH SCH ',I6)
IF(NOBJ) 800,400,300 ! test result.
300 CHOMP=.FALSE. ! reachable.
IF(OBJ.EQ.NOBJ) GO TO 400 ! same as before?
IF(OBJ.NE.0) NOBJ=-NOBJ ! amb result?
OBJ=NOBJ
C
400 NOBJ=SCHLST(OIDX,AIDX,0,0,WINNER,SPCOBJ) ! search adventurer.
IF(DFLAG) WRITE(OUTCH,430) NOBJ
430 FORMAT(' SCHLST- ADV SCH ',I6)
IF(NOBJ) 800,900,500 ! test result
500 IF(OBJ.EQ.0) GO TO 800 ! any previous? no, use nobj.
IF(AIDX.NE.0) GO TO 600 ! yes, amb, any adj?
IF(NOADJS(OBJ).NEQV.NOADJS(NOBJ)) GO TO 700 ! both adj or no adj?
600 OBJ=-NOBJ ! ambiguous result.
GO TO 900
700 IF(NOADJS(OBJ)) GO TO 900 ! if old no adj, use old.
800 OBJ=NOBJ ! return new object.
900 IF(CHOMP) OBJ=-10000 ! unreachable.
1000 GETOBJ=OBJ
C
IF(GETOBJ.NE.0) GO TO 1500 ! got something?
DO 1200 I=STRBIT+1,OLNT ! no, search globals.
IF(.NOT.THISIT(OIDX,AIDX,I,SPCOBJ)) GO TO 1200
IF(.NOT.GHERE(I,HERE)) GO TO 1200 ! can it be here?
IF(GETOBJ.EQ.0) GO TO 1150 ! got one yet?
IF(AIDX.NE.0) GO TO 1050 ! yes, no adj?
IF(NOADJS(GETOBJ).NEQV.NOADJS(I)) GO TO 1100 ! only one with no adj?
1050 GETOBJ=-I ! ambiguous
GO TO 1200
1100 IF(NOADJS(GETOBJ)) GO TO 1200 ! if old no adj, retain.
1150 GETOBJ=I ! new is target.
1200 CONTINUE
C
1500 CONTINUE ! end of search.
IF(DFLAG) WRITE(OUTCH,1540) GETOBJ
1540 FORMAT(' SCHLST- RESULT ',I6)
RETURN
END
C SCHLST-- Search for object
C
C Declarations
C
INTEGER FUNCTION SCHLST(OIDX,AIDX,RM,CN,AD,SPCOBJ)
IMPLICIT INTEGER(A-Z)
INCLUDE 'dparam.for'
LOGICAL THISIT,QHERE,NOTRAN,NOVIS,AEMPTY,NOADJS
C
C Functions and data
C
NOTRAN(O)=((OFLAG1(O).AND.TRANBT).EQ.0).AND.
1((OFLAG2(O).AND.OPENBT).EQ.0)
NOVIS(O)=((OFLAG1(O).AND.VISIBT).EQ.0)
C
SCHLST=0 ! no result.
AEMPTY=.FALSE. ! no ambiguous empty.
DO 1000 I=1,OLNT ! search objects.
IF(NOVIS(I).OR.
1(((RM.EQ.0).OR.(.NOT.QHERE(I,RM))).AND.
2 ((CN.EQ.0).OR.(OCAN(I).NE.CN)).AND.
3 ((AD.EQ.0).OR.(OADV(I).NE.AD)))) GO TO 1000
IF(.NOT.THISIT(OIDX,AIDX,I,SPCOBJ)) GO TO 200
IF(SCHLST.EQ.0) GO TO 150 ! got one already?
IF(AIDX.NE.0) GO TO 2000 ! adj? then ambiguous
IF(NOADJS(I)) GO TO 100 ! new have no adj?
AEMPTY=.TRUE. ! no, old might, flag.
GO TO 200
100 IF(NOADJS(SCHLST)) GO TO 2000 ! old have no adj?
150 SCHLST=I ! new is unique, or
! new has no adj, old does.
C
C If open or transparent, search the object itself.
C
200 IF(NOTRAN(I)) GO TO 1000
C
C Search is conducted in reverse. All objects are checked to
C See if they are at some level of containment inside object 'I'.
C If they are at level 1, or if all links in the containment
C chain are open, visible, and have SEARCHME set, they can qualify
C as a potential match.
C
DO 500 J=1,OLNT ! search objects.
IF(NOVIS(J).OR. (.NOT.THISIT(OIDX,AIDX,J,SPCOBJ)))
1GO TO 500 ! visible & match?
X=OCAN(J) ! get container.
300 IF(X.EQ.I) GO TO 400 ! inside target?
IF(X.EQ.0) GO TO 500 ! inside anything?
IF(NOVIS(X).OR.NOTRAN(X).OR.
1((OFLAG2(X).AND.SCHBT).EQ.0)) GO TO 500
X=OCAN(X) ! go another level.
GO TO 300
C
400 IF(SCHLST.EQ.0) GO TO 450 ! already got one?
IF(AIDX.NE.0) GO TO 2000 ! adj? then ambiguous.
IF(NOADJS(J)) GO TO 425 ! new have no adj?
AEMPTY=.TRUE. ! no, ambiguous empty.
GO TO 500
425 IF(NOADJS(SCHLST)) GO TO 2000 ! old have no adj? then amb.
450 SCHLST=J ! new is unique, or
! new has no adj, and old does.
500 CONTINUE
C
1000 CONTINUE
IF(.NOT.AEMPTY.OR.(SCHLST.EQ.0)) RETURN ! if none or not amb, done.
IF(NOADJS(SCHLST)) RETURN ! if amb, and no adj, done.
2000 SCHLST=-SCHLST ! amb return.
RETURN
C
END
C THISIT-- Validate object vs description
C
C Declarations
C
LOGICAL FUNCTION THISIT(OIDX,AIDX,OBJ,SPCOBJ)
IMPLICIT INTEGER(A-Z)
INCLUDE 'dparam.for'
C
THISIT=.FALSE. ! assume no match.
IF((SPCOBJ.NE.0).AND.(OBJ.EQ.SPCOBJ)) GO TO 500
C
C Check for object names
C
IF(OIDX.EQ.0) RETURN ! no obj? lose.
I=OIDX
100 IF(IABS(OVOC(I)).EQ.OBJ) GO TO 200 ! found it?
I=I+1 ! adv to next.
IF(OVOC(I).LT.0) GO TO 100 ! still part of list?
RETURN ! if done, lose.
C
200 IF(AIDX.EQ.0) GO TO 500 ! no adj? done.
I=AIDX
300 IF(IABS(AVOC(I)).EQ.OBJ) GO TO 500 ! found it?
I=I+1 ! adv to next.
IF(AVOC(I).LT.0) GO TO 300 ! still part of list?
RETURN ! if done, lose.
C
500 THISIT=.TRUE.
RETURN
END
C SYNMCH-- Syntax matcher
C
C Declarations
C
C This routine details on bit 4 of PRSFLG
C
LOGICAL FUNCTION SYNMCH(X)
IMPLICIT INTEGER(A-Z)
INCLUDE 'dparam.for'
LOGICAL SYNEQL,TAKEIT,DFLAG
CHARACTER*(TEXLNT) STR
CHARACTER*(WRDLNT) FINDVB,FINDPR,LCIFY,LCWORD
CHARACTER*(WRDLNT+2) LCPRP1,LCPRP2
C SYNMCH, PAGE 2
C
SYNMCH=.FALSE.
DFLAG=(PRSFLG.AND.16).NE.0
J=ACT ! set up ptr to syntax.
DRIVE=0 ! no default.
DFORCE=0 ! no forced default.
QPREP=OFLAG.AND.OPREP ! valid orphan prep flag.
LIMIT=J+VVOC(J)+1 ! compute limit.
J=J+1 ! advance to next.
C
200 CALL UNPACK(J,NEWJ) ! unpack syntax.
IF(DFLAG) WRITE(OUTCH,210) J,OBJ1,PREP1,DOBJ,DFL1,DFL2
210 FORMAT(' SYNMCH DOBJ INPUTS TO SYNEQL- ',6I7)
SPREP=DOBJ.AND.VPMASK ! save expected prep.
IF(SYNEQL(PREP1,OBJ1,DOBJ,DFL1,DFL2)) GO TO 1000
C
C Direct syntax match fails, try direct as indirect.
C
IF((OBJ2.NE.0).OR.(OBJ1.EQ.0).OR.
1(.NOT.SYNEQL(PREP1,OBJ1,IOBJ,IFL1,IFL2)))
2GO TO 500 ! try direct as indirect.
OBJ2=OBJ1 ! move direct to indirect.
PREP2=PREP1
OBJ1=0 ! no direct.
PREP1=0
DRIVE=J ! save as driver.
GO TO 3100 ! go try to get direct obj
C
C Direct syntax match and direct-as-indirect fail.
C
500 IF(OBJ1.NE.0) GO TO 3000 ! if direct obj, on to next.
GO TO 2500 ! go do defaults.
C
C Direct syntax match succeeded, try indirect.
C
1000 IF(DFLAG) WRITE(OUTCH,1010) J,OBJ2,PREP2,IOBJ,IFL1,IFL2
1010 FORMAT(' SYNMCH IOBJ INPUTS TO SYNEQL- ',6I7)
SPREP=IOBJ.AND.VPMASK ! save expected prep.
IF(SYNEQL(PREP2,OBJ2,IOBJ,IFL1,IFL2)) GO TO 6000
C
C Indirect syntax match fails.
C
IF(OBJ2.NE.0) GO TO 3000 ! if ind object, on to next.
2500 IF((QPREP.EQ.0).OR.(QPREP.EQ.SPREP)) DFORCE=J ! if prep mch.
IF((VFLAG.AND.SDRIV).NE.0) DRIVE=J ! if driver, record.
IF(DFLAG) WRITE(OUTCH,2510) J,QPREP,SPREP,DFORCE,DRIVE
2510 FORMAT(' SYNMCH DEFAULT SYNTAXES- ',5I7)
3000 J=NEWJ
IF(J.LT.LIMIT) GO TO 200 ! more to do?
C SYNMCH, PAGE 3
C
C Match has failed. If default syntax exists, try to snarf
C orphans or GWIMs, or make new orphans.
C
3100 IF(DFLAG) WRITE(OUTCH,3110) DRIVE,DFORCE,OBJ1,OBJ2
3110 FORMAT(' SYNMCH, DRIVE=',2I6,' OBJECTS =',2I6)
IF(DRIVE.EQ.0) DRIVE=DFORCE ! no driver? use force.
IF(DRIVE.EQ.0) GO TO 10000 ! any driver?
CALL UNPACK(DRIVE,DFORCE) ! unpack dflt syntax.
LCWORD=LCIFY(FINDVB(DRIVE),2) ! get verb string.
LCPRP1=' '//LCIFY(FINDPR(DOBJ.AND.VPMASK),1)//' '
LCPRP2=' '//LCIFY(FINDPR(IOBJ.AND.VPMASK),1)//' '
C
C Try to fill direct object slot if that was the problem.
C
IF(((VFLAG.AND.SDIR).EQ.0).OR.(OBJ1.NE.0)) GO TO 4000
OBJ1=OFLAG.AND.OOBJ1
IF(OBJ1.EQ.0) GO TO 3500 ! any orphan?
IF(SYNEQL(OPREP1,OBJ1,DOBJ,DFL1,DFL2)) GO TO 4000
C
C Orphan fails, try GWIM.
C
3500 OBJ1=GWIM(DOBJ,DFW1,DFW2) ! get gwim.
IF(DFLAG) WRITE(OUTCH,3530) OBJ1
3530 FORMAT(' SYNMCH- DO GWIM= ',I6)
IF(OBJ1.GT.0) GO TO 4000 ! test result.
CALL ORPHAN(-1,ACT,0,0,DOBJ.AND.VPMASK,' ',PREP2,OBJ2) ! fails, orphan.
BUNSUB=0 ! no EXCEPT clause.
IF(OBJ2.GT.0) GO TO 3800 ! if iobj, go print.
3700 WRITE(OUTCH,3750)
1LCWORD(1:NBLEN(LCWORD)),LCPRP1(1:NBLEN(LCPRP1)+1)
3750 FORMAT(1X,A,A,'what?')
TELFLG=.TRUE.
RETURN
C
3800 X=IABS(ODESC2(OBJ2)) ! get iobj description.
READ(DBCH,REC=X) J,STR ! read data base.
CALL TXCRYP(X,STR) ! decrypt the line.
WRITE(OUTCH,3880) LCWORD(1:NBLEN(LCWORD)),
1LCPRP1(1:NBLEN(LCPRP1)+1),
2LCPRP2(1:NBLEN(LCPRP2)+1),STR(1:NBLEN(STR))
3880 FORMAT(1X,A,A,'what',A,'the ',A,'?')
TELFLG=.TRUE.
RETURN
C SYNMCH, PAGE 4
C
C Try to fill indirect object slot if that was the problem.
C
4000 IF(((VFLAG.AND.SIND).EQ.0).OR.(OBJ2.NE.0)) GO TO 6000
OBJ2=OFLAG.AND.OOBJ2
IF(OBJ2.EQ.0) GO TO 4500 ! any orphan?
IF(SYNEQL(OPREP2,OBJ2,IOBJ,IFL1,IFL2)) GO TO 6000
C
C Orphan fails, try GWIM.
C
4500 OBJ2=GWIM(IOBJ,IFW1,IFW2) ! gwim.
IF(DFLAG) WRITE(OUTCH,4550) OBJ2
4550 FORMAT(' SYNMCH- IO GWIM= ',I6)
IF(OBJ2.GT.0) GO TO 6000
IF(OBJ1.GT.0) GO TO 4600 ! if dobj, go print.
CALL ORPHAN(-1,ACT,OFLAG.AND.OPREP1,
1OFLAG.AND.OOBJ1,IOBJ.AND.VPMASK,' ',0,0)
GO TO 3700
C
C Error with direct object available.
C
4600 CALL ORPHAN(-1,ACT,PREP1,OBJ1,IOBJ.AND.VPMASK,' ',0,0)
X=IABS(ODESC2(OBJ1)) ! get dobj description.
READ(DBCH,REC=X) J,STR ! read data base.
CALL TXCRYP(X,STR) ! decrypt the line.
WRITE(OUTCH,4660) LCWORD(1:NBLEN(LCWORD)),
1LCPRP1(1:NBLEN(LCPRP1)+1),
2STR(1:NBLEN(STR)),LCPRP2(1:NBLEN(LCPRP2)+1)
4660 FORMAT(1X,A,A,'the ',A,A,'what?')
TELFLG=.TRUE.
RETURN
C
C Total chomp.
C
10000 CALL RSPEAK(601) ! cant do anything.
BUNSUB=0
RETURN
C SYNMCH, PAGE 5
C
C Now try to take individual objects and
C in general clean up the parse vector.
C
6000 IF((VFLAG.AND.SFLIP).EQ.0) GO TO 7000 ! flip?
J=OBJ1 ! yes.
OBJ1=OBJ2
OBJ2=J
C
7000 PRSA=VFLAG.AND.SVMASK ! get verb.
PRSO=OBJ1 ! get dir obj.
PRSI=OBJ2 ! get ind obj.
IF(.NOT.TAKEIT(PRSO,DOBJ)) RETURN ! try take.
IF(.NOT.TAKEIT(PRSI,IOBJ)) RETURN ! try take.
SYNMCH=.TRUE.
IF(DFLAG) WRITE(OUTCH,7050) SYNMCH,PRSA,PRSO,PRSI,ACT,OBJ1,OBJ2
7050 FORMAT(' SYNMCH- RESULTS ',L1,6I7)
RETURN
C
END
C UNPACK- Unpack syntax specification, adv pointer
C
C Declarations
C
SUBROUTINE UNPACK(OLDJ,J)
IMPLICIT INTEGER(A-Z)
INCLUDE 'dparam.for'
C
DO 10 I=1,11 ! clear syntax.
SYN(I)=0
10 CONTINUE
C
VFLAG=VVOC(OLDJ)
J=OLDJ+1
IF((VFLAG.AND.SDIR).EQ.0) RETURN ! dir object?
DFL1=-1 ! assume std.
DFL2=-1
IF((VFLAG.AND.SSTD).EQ.0) GO TO 100 ! std object?
DFW1=-1 ! yes.
DFW2=-1
DOBJ=VABIT+VRBIT+VFBIT
GO TO 200
C
100 DOBJ=VVOC(J) ! not std.
DFW1=VVOC(J+1)
DFW2=VVOC(J+2)
J=J+3
IF((DOBJ.AND.VEBIT).EQ.0) GO TO 200 ! vbit = vfwim?
DFL1=DFW1 ! yes.
DFL2=DFW2
C
200 IF((VFLAG.AND.SIND).EQ.0) RETURN ! ind object?
IFL1=-1 ! assume std.
IFL2=-1
IOBJ=VVOC(J)
IFW1=VVOC(J+1)
IFW2=VVOC(J+2)
J=J+3
IF((IOBJ.AND.VEBIT).EQ.0) RETURN ! vbit = vfwim?
IFL1=IFW1 ! yes.
IFL2=IFW2
RETURN
C
END
C SYNEQL- Test for syntax equality
C
C Declarations
C
LOGICAL FUNCTION SYNEQL(PREP,OBJ,SPREP,SFL1,SFL2)
IMPLICIT INTEGER(A-Z)
INCLUDE 'dparam.for'
C
IF(OBJ.EQ.0) GO TO 100 ! any object?
SYNEQL=(PREP.EQ.(SPREP.AND.VPMASK)).AND.
1(((SFL1.AND.OFLAG1(OBJ)).OR.
2 (SFL2.AND.OFLAG2(OBJ))).NE.0)
RETURN
C
100 SYNEQL=(PREP.EQ.0).AND.(SFL1.EQ.0).AND.(SFL2.EQ.0)
RETURN
C
END
C TAKEIT- Parser based take of object
C
C Declarations
C
LOGICAL FUNCTION TAKEIT(OBJ,SFLAG)
IMPLICIT INTEGER(A-Z)
INCLUDE 'dparam.for'
LOGICAL TAKE,LIT
C
TAKEIT=.FALSE. ! assume loses.
IF((OBJ.EQ.0).OR.(OBJ.GT.STRBIT).OR.DEADF)
1GO TO 4000 ! null/stars/dead win.
ODO2=ODESC2(OBJ) ! get desc.
X=OCAN(OBJ) ! get container.
IF((X.EQ.0).OR.((SFLAG.AND.VFBIT).EQ.0)) GO TO 500
IF((OFLAG2(X).AND.OPENBT).NE.0) GO TO 500
CALL RSPSUB(566,ODO2) ! cant reach.
RETURN
C
500 IF((SFLAG.AND.VRBIT).EQ.0) GO TO 1000 ! shld be in room?
IF((SFLAG.AND.VTBIT).EQ.0) GO TO 2000 ! can be taken?
C
C Should be in room (VRBIT NE 0) and can be taken (VTBIT NE 0)
C
IF(SCHLST(0,0,HERE,0,0,OBJ).LE.0) GO TO 4000 ! if not, ok.
C
C Its in the room and can be taken.
C
IF((OFLAG1(OBJ).AND.TAKEBT).NE.0) GO TO 3000
C
C Not takeable. If we care, fail.
C
IF((SFLAG.AND.VCBIT).EQ.0) GO TO 4000 ! if no care, return.
CALL RSPSUB(445,ODO2)
RETURN
C
C 1000-- It should not be in the room.
C 2000-- It cant be taken.
C
2000 IF((SFLAG.AND.VCBIT).EQ.0) GO TO 4000 ! if no care, return
1000 IF(SCHLST(0,0,HERE,0,0,OBJ).LE.0) GO TO 4000
I=665 ! assume player.
IF(WINNER.NE.PLAYER) I=1082
CALL RSPSUB(I,ODO2) ! doesn't have it.
RETURN
C
C 3000-- Take object.
C
3000 IF(LIT(HERE)) GO TO 3500 ! lit?
CALL RSPEAK(579) ! can't do it.
RETURN
C
3500 SVA=PRSA ! save parse vector
SVO=PRSO
SVI=PRSI
PRSA=TAKEW ! make 'take obj'
PRSO=OBJ
PRSI=0 ! no indirect object
TAKEIT=TAKE(.TRUE.) ! try to take object
PRSA=SVA ! restore parse vector.
PRSO=SVO
PRSI=SVI
RETURN
C
C 4000-- Win on general principles.
C
4000 TAKEIT=.TRUE.
RETURN
C
END
C GWIM- Get what I mean in ambiguous situations
C
C Declarations
C
INTEGER FUNCTION GWIM(SFLAG,SFW1,SFW2)
IMPLICIT INTEGER(A-Z)
INCLUDE 'dparam.for'
LOGICAL TAKEIT,NOCARE,LIT
C
GWIM=0 ! no result.
IF(DEADF) RETURN ! dead? gwim disabled.
AV=AVEHIC(WINNER)
NOCARE=(SFLAG.AND.VCBIT).EQ.0
C
C First search adventurer
C
IF((SFLAG.AND.VABIT).NE.0)
1GWIM=FWIM(SFW1,SFW2,0,0,WINNER,NOCARE)
IF((GWIM.LT.0).OR..NOT.LIT(HERE).OR.
1 ((SFLAG.AND.VRBIT).EQ.0)) RETURN
C
C Also search room
C
100 ROBJ=FWIM(SFW1,SFW2,HERE,0,0,NOCARE)
IF(ROBJ) 500,600,200 ! test result.
C
C ROBJ > 0: if prev object, fail
C
200 IF((AV.EQ.0).OR.(ROBJ.EQ.AV).OR.
1((OFLAG2(ROBJ).AND.FINDBT).NE.0)) GO TO 300
IF(OCAN(ROBJ).NE.AV) RETURN ! unreachable? use prev obj.
C
300 IF(GWIM.EQ.0) GO TO 400 ! prev obj?
GWIM=-GWIM ! yes, ambiguous.
RETURN
C
400 IF(.NOT.TAKEIT(ROBJ,SFLAG)) RETURN ! if untakeable, return prev.
500 GWIM=ROBJ ! return room seach.
600 RETURN
C
END
C NOADJS- See if any adjectives for object
C
C Declarations
C
LOGICAL FUNCTION NOADJS(OBJ)
IMPLICIT INTEGER(A-Z)
INCLUDE 'dparam.for'
C
NOADJS=.FALSE. ! assume false.
DO 100 I=1,AVMAX ! search adj.
IF(IABS(AVOC(I)).EQ.OBJ) RETURN ! found adjective?
IF(AVOC(I).EQ.0) GO TO 200 ! end of list?
100 CONTINUE
200 NOADJS=.TRUE. ! true.
RETURN
C
END
C LCIFY- "Lower case"-ify a string for printing
C
C Declarations
C
CHARACTER*(*) FUNCTION LCIFY(STRING,START)
IMPLICIT INTEGER(A-Z)
CHARACTER*(*) STRING
C
LCIFY=STRING ! assume input = output.
K=LEN(STRING) ! get input length.
IF(START.GT.K) RETURN ! anything to convert?
C
ULCVT=ICHAR('a')-ICHAR('A') ! conversion factor
DO 100 I=START,K ! loop on characters
IF((STRING(I:I).GE.'A').AND.(STRING(I:I).LE.'Z'))
1LCIFY(I:I)=CHAR(ICHAR(STRING(I:I))+ULCVT)
100 CONTINUE
RETURN
C
END
C FINDVB- Find verb string corresponding to syntax.
C
C Declarations
C
CHARACTER*(*) FUNCTION FINDVB(SYNTAX)
IMPLICIT INTEGER(A-Z)
INCLUDE 'dparam.for'
C
J=1
DO 100 K=1,VWMAX ! loop through verbs
NEWJ=J+VVOC(J)+1 ! start of next syntax
IF((J.LE.SYNTAX).AND.(SYNTAX.LT.NEWJ)) GO TO 200
IF(VWORD(K)(1:1).NE.'*') J=NEWJ ! if last synonym, advance.
100 CONTINUE
FINDVB=' ' ! disaster
RETURN
C
200 FINDVB=VWORD(K) ! return string
IF(VWORD(K)(1:1).EQ.'*') FINDVB=VWORD(K)(2:WRDLNT)
RETURN
C
END
C FINDPR- Find preposition string corresponding to index.
C
C Declarations
C
CHARACTER*(*) FUNCTION FINDPR(PREPNO)
IMPLICIT INTEGER(A-Z)
INCLUDE 'dparam.for'
C
DO 100 I=1,PWMAX ! loop through prepositions.
IF(PVOC(I).EQ.PREPNO) GO TO 200
100 CONTINUE
FINDPR=' '
RETURN
C
200 FINDPR=PWORD(I)
RETURN
C
END